home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_emacs.idb / usr / freeware / share / emacs / 19.34 / lisp / gnus-srvr.el.z / gnus-srvr.el
Encoding:
Text File  |  1998-10-28  |  22.2 KB  |  709 lines
  1. ;;; gnus-srvr.el --- virtual server support for Gnus
  2. ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;; Keywords: news
  6.  
  7. ;; This file is part of GNU Emacs.
  8.  
  9. ;; GNU Emacs is free software; you can redistribute it and/or modify
  10. ;; it under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; GNU Emacs is distributed in the hope that it will be useful,
  15. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17. ;; GNU General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22. ;; Boston, MA 02111-1307, USA.
  23.  
  24. ;;; Commentary:
  25.  
  26. ;;; Code:
  27.  
  28. (require 'gnus)
  29. (eval-when-compile (require 'cl))
  30.  
  31. (defvar gnus-server-mode-hook nil
  32.   "Hook run in `gnus-server-mode' buffers.")
  33.  
  34. (defconst gnus-server-line-format "     {%(%h:%w%)} %s\n"
  35.   "Format of server lines.
  36. It works along the same lines as a normal formatting string,
  37. with some simple extensions.")
  38.  
  39. (defvar gnus-server-mode-line-format "Gnus  List of servers"
  40.   "The format specification for the server mode line.")
  41.  
  42. (defvar gnus-server-exit-hook nil
  43.   "*Hook run when exiting the server buffer.")
  44.  
  45. ;;; Internal variables.
  46.  
  47. (defvar gnus-inserted-opened-servers nil)
  48.  
  49. (defvar gnus-server-line-format-alist
  50.   `((?h how ?s)
  51.     (?n name ?s)
  52.     (?w where ?s)
  53.     (?s status ?s)))
  54.  
  55. (defvar gnus-server-mode-line-format-alist 
  56.   `((?S news-server ?s)
  57.     (?M news-method ?s)
  58.     (?u user-defined ?s)))
  59.  
  60. (defvar gnus-server-line-format-spec nil)
  61. (defvar gnus-server-mode-line-format-spec nil)
  62. (defvar gnus-server-killed-servers nil)
  63.  
  64. (defvar gnus-server-mode-map)
  65.  
  66. (defvar gnus-server-menu-hook nil
  67.   "*Hook run after the creation of the server mode menu.")
  68.  
  69. (defun gnus-server-make-menu-bar ()
  70.   (gnus-visual-turn-off-edit-menu 'server)
  71.   (unless (boundp 'gnus-server-server-menu)
  72.     (easy-menu-define
  73.      gnus-server-server-menu gnus-server-mode-map ""
  74.      '("Server"
  75.        ["Add" gnus-server-add-server t]
  76.        ["Browse" gnus-server-read-server t]
  77.        ["List" gnus-server-list-servers t]
  78.        ["Kill" gnus-server-kill-server t]
  79.        ["Yank" gnus-server-yank-server t]
  80.        ["Copy" gnus-server-copy-server t]
  81.        ["Edit" gnus-server-edit-server t]
  82.        ["Exit" gnus-server-exit t]
  83.        ))
  84.  
  85.     (easy-menu-define
  86.      gnus-server-connections-menu gnus-server-mode-map ""
  87.      '("Connections"
  88.        ["Open" gnus-server-open-server t]
  89.        ["Close" gnus-server-close-server t]
  90.        ["Deny" gnus-server-deny-server t]
  91.        ["Reset" gnus-server-remove-denials t]
  92.        ))
  93.  
  94.     (run-hooks 'gnus-server-menu-hook)))
  95.  
  96. (defvar gnus-server-mode-map nil)
  97. (put 'gnus-server-mode 'mode-class 'special)
  98.  
  99. (unless gnus-server-mode-map
  100.   (setq gnus-server-mode-map (make-sparse-keymap))
  101.   (suppress-keymap gnus-server-mode-map)
  102.  
  103.   (gnus-define-keys
  104.    gnus-server-mode-map
  105.    " " gnus-server-read-server
  106.    "\r" gnus-server-read-server
  107.    gnus-mouse-2 gnus-server-pick-server
  108.    "q" gnus-server-exit
  109.    "l" gnus-server-list-servers
  110.    "k" gnus-server-kill-server
  111.    "y" gnus-server-yank-server
  112.    "c" gnus-server-copy-server
  113.    "a" gnus-server-add-server
  114.    "e" gnus-server-edit-server
  115.  
  116.    "O" gnus-server-open-server
  117.    "C" gnus-server-close-server
  118.    "D" gnus-server-deny-server
  119.    "R" gnus-server-remove-denials
  120.  
  121.     "\C-c\C-i" gnus-info-find-node))
  122.  
  123. (defun gnus-server-mode ()
  124.   "Major mode for listing and editing servers.
  125.  
  126. All normal editing commands are switched off.
  127. \\<gnus-server-mode-map>
  128. For more in-depth information on this mode, read the manual 
  129. (`\\[gnus-info-find-node]'). 
  130.  
  131. The following commands are available:
  132.  
  133. \\{gnus-server-mode-map}"
  134.   (interactive)
  135.   (when (and menu-bar-mode
  136.          (gnus-visual-p 'server-menu 'menu))
  137.     (gnus-server-make-menu-bar))
  138.   (kill-all-local-variables)
  139.   (gnus-simplify-mode-line)
  140.   (setq major-mode 'gnus-server-mode)
  141.   (setq mode-name "Server")
  142.                     ;  (gnus-group-set-mode-line)
  143.   (setq mode-line-process nil)
  144.   (use-local-map gnus-server-mode-map)
  145.   (buffer-disable-undo (current-buffer))
  146.   (setq truncate-lines t)
  147.   (setq buffer-read-only t)
  148.   (run-hooks 'gnus-server-mode-hook))
  149.  
  150. (defun gnus-server-insert-server-line (name method)
  151.   (let* ((how (car method))
  152.      (where (nth 1 method))
  153.      (elem (assoc method gnus-opened-servers))
  154.      (status (cond ((eq (nth 1 elem) 'denied)
  155.             "(denied)")
  156.                ((or (gnus-server-opened method)
  157.                 (eq (nth 1 elem) 'ok))
  158.             "(opened)")
  159.                (t
  160.             "(closed)"))))
  161.     (beginning-of-line)
  162.     (gnus-add-text-properties
  163.      (point)
  164.      (prog1 (1+ (point))
  165.        ;; Insert the text.
  166.        (eval gnus-server-line-format-spec))
  167.      (list 'gnus-server (intern name)))))
  168.  
  169. (defun gnus-enter-server-buffer ()
  170.   "Set up the server buffer."
  171.   (gnus-server-setup-buffer)
  172.   (gnus-configure-windows 'server)
  173.   (gnus-server-prepare))
  174.  
  175. (defun gnus-server-setup-buffer ()
  176.   "Initialize the server buffer."
  177.   (unless (get-buffer gnus-server-buffer)
  178.     (save-excursion
  179.       (set-buffer (get-buffer-create gnus-server-buffer))
  180.       (gnus-server-mode)
  181.       (when gnus-carpal 
  182.     (gnus-carpal-setup-buffer 'server)))))
  183.  
  184. (defun gnus-server-prepare ()
  185.   (setq gnus-server-mode-line-format-spec 
  186.     (gnus-parse-format gnus-server-mode-line-format 
  187.                gnus-server-mode-line-format-alist))
  188.   (setq gnus-server-line-format-spec 
  189.     (gnus-parse-format gnus-server-line-format 
  190.                gnus-server-line-format-alist t))
  191.   (let ((alist gnus-server-alist)
  192.     (buffer-read-only nil)
  193.     (opened gnus-opened-servers)
  194.     done server op-ser)
  195.     (erase-buffer)
  196.     (setq gnus-inserted-opened-servers nil)
  197.     ;; First we do the real list of servers.
  198.     (while alist
  199.       (push (cdr (setq server (pop alist))) done)
  200.       (when (and server (car server) (cdr server))
  201.     (gnus-server-insert-server-line (car server) (cdr server))))
  202.     ;; Then we insert the list of servers that have been opened in
  203.     ;; this session.
  204.     (while opened 
  205.       (unless (member (caar opened) done)
  206.     (gnus-server-insert-server-line 
  207.      (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened))))
  208.      (caar opened))
  209.     (push (list op-ser (caar opened)) gnus-inserted-opened-servers))
  210.       (setq opened (cdr opened))))
  211.   (goto-char (point-min))
  212.   (gnus-server-position-point))
  213.  
  214. (defun gnus-server-server-name ()
  215.   (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
  216.     (and server (symbol-name server))))
  217.  
  218. (defalias 'gnus-server-position-point 'gnus-goto-colon)
  219.  
  220. (defconst gnus-server-edit-buffer "*Gnus edit server*")
  221.  
  222. (defun gnus-server-update-server (server)
  223.   (save-excursion
  224.     (set-buffer gnus-server-buffer)
  225.     (let* ((buffer-read-only nil)
  226.        (entry (assoc server gnus-server-alist))
  227.        (oentry (assoc (gnus-server-to-method server)
  228.               gnus-opened-servers)))
  229.       (when entry
  230.     (gnus-dribble-enter 
  231.      (concat "(gnus-server-set-info \"" server "\" '"
  232.          (prin1-to-string (cdr entry)) ")")))
  233.       (when (or entry oentry)
  234.     ;; Buffer may be narrowed.
  235.     (save-restriction
  236.       (widen)
  237.       (when (gnus-server-goto-server server)
  238.         (gnus-delete-line))
  239.       (if entry
  240.           (gnus-server-insert-server-line (car entry) (cdr entry))
  241.         (gnus-server-insert-server-line 
  242.          (format "%s:%s" (caar oentry) (nth 1 (car oentry)))
  243.          (car oentry)))
  244.       (gnus-server-position-point))))))
  245.  
  246. (defun gnus-server-set-info (server info)
  247.   ;; Enter a select method into the virtual server alist.
  248.   (when (and server info)
  249.     (gnus-dribble-enter 
  250.      (concat "(gnus-server-set-info \"" server "\" '"
  251.          (prin1-to-string info) ")"))
  252.     (let* ((server (nth 1 info))
  253.        (entry (assoc server gnus-server-alist)))
  254.       (if entry (setcdr entry info)
  255.     (setq gnus-server-alist
  256.           (nconc gnus-server-alist (list (cons server info))))))))
  257.  
  258. ;;; Interactive server functions.
  259.  
  260. (defun gnus-server-kill-server (server)
  261.   "Kill the server on the current line."
  262.   (interactive (list (gnus-server-server-name)))
  263.   (unless (gnus-server-goto-server server)
  264.     (if server (error "No such server: %s" server)
  265.       (error "No server on the current line")))
  266.   (unless (assoc server gnus-server-alist)
  267.     (error "Read-only server %s" server))
  268.   (gnus-dribble-enter "")
  269.   (let ((buffer-read-only nil))
  270.     (gnus-delete-line))
  271.   (setq gnus-server-killed-servers 
  272.     (cons (assoc server gnus-server-alist) gnus-server-killed-servers))
  273.   (setq gnus-server-alist (delq (car gnus-server-killed-servers)
  274.                 gnus-server-alist))
  275.   (gnus-server-position-point))
  276.  
  277. (defun gnus-server-yank-server ()
  278.   "Yank the previously killed server."
  279.   (interactive)
  280.   (or gnus-server-killed-servers
  281.       (error "No killed servers to be yanked"))
  282.   (let ((alist gnus-server-alist)
  283.     (server (gnus-server-server-name))
  284.     (killed (car gnus-server-killed-servers)))
  285.     (if (not server) 
  286.     (setq gnus-server-alist (nconc gnus-server-alist (list killed)))
  287.       (if (string= server (caar gnus-server-alist))
  288.       (setq gnus-server-alist (cons killed gnus-server-alist))
  289.     (while (and (cdr alist)
  290.             (not (string= server (caadr alist))))
  291.       (setq alist (cdr alist)))
  292.     (if alist
  293.         (setcdr alist (cons killed (cdr alist)))
  294.        (setq gnus-server-alist (list killed)))))
  295.     (gnus-server-update-server (car killed))
  296.     (setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
  297.     (gnus-server-position-point)))
  298.  
  299. (defun gnus-server-exit ()
  300.   "Return to the group buffer."
  301.   (interactive)
  302.   (kill-buffer (current-buffer))
  303.   (switch-to-buffer gnus-group-buffer)
  304.   (run-hooks 'gnus-server-exit-hook))
  305.  
  306. (defun gnus-server-list-servers ()
  307.   "List all available servers."
  308.   (interactive)
  309.   (let ((cur (gnus-server-server-name)))
  310.     (gnus-server-prepare)
  311.     (if cur (gnus-server-goto-server cur)
  312.       (goto-char (point-max))
  313.       (forward-line -1))
  314.     (gnus-server-position-point)))
  315.  
  316. (defun gnus-server-set-status (method status)
  317.   "Make METHOD have STATUS."
  318.   (let ((entry (assoc method gnus-opened-servers)))
  319.     (if entry
  320.     (setcar (cdr entry) status)
  321.       (push (list method status) gnus-opened-servers))))
  322.  
  323. (defun gnus-opened-servers-remove (method)
  324.   "Remove METHOD from the list of opened servers."
  325.   (setq gnus-opened-servers (delq (assoc method gnus-opened-servers)
  326.                   gnus-opened-servers)))
  327.  
  328. (defun gnus-server-open-server (server)
  329.   "Force an open of SERVER."
  330.   (interactive (list (gnus-server-server-name)))
  331.   (let ((method (gnus-server-to-method server)))
  332.     (or method (error "No such server: %s" server))
  333.     (gnus-server-set-status method 'ok)
  334.     (prog1
  335.     (or (gnus-open-server method)
  336.         (progn (message "Couldn't open %s" server) nil))
  337.       (gnus-server-update-server server)
  338.       (gnus-server-position-point))))
  339.  
  340. (defun gnus-server-close-server (server)
  341.   "Close SERVER."
  342.   (interactive (list (gnus-server-server-name)))
  343.   (let ((method (gnus-server-to-method server)))
  344.     (or method (error "No such server: %s" server))
  345.     (gnus-server-set-status method 'closed)
  346.     (prog1
  347.     (gnus-close-server method)
  348.       (gnus-server-update-server server)
  349.       (gnus-server-position-point))))
  350.  
  351. (defun gnus-server-deny-server (server)
  352.   "Make sure SERVER will never be attempted opened."
  353.   (interactive (list (gnus-server-server-name)))
  354.   (let ((method (gnus-server-to-method server)))
  355.     (or method (error "No such server: %s" server))
  356.     (gnus-server-set-status method 'denied))
  357.   (gnus-server-update-server server)
  358.   (gnus-server-position-point)
  359.   t)
  360.  
  361. (defun gnus-server-remove-denials ()
  362.   "Make all denied servers into closed servers."
  363.   (interactive)
  364.   (let ((servers gnus-opened-servers))
  365.     (while servers
  366.       (when (eq (nth 1 (car servers)) 'denied)
  367.     (setcar (nthcdr 1 (car servers)) 'closed))
  368.       (setq servers (cdr servers))))
  369.   (gnus-server-list-servers))
  370.  
  371. (defun gnus-server-copy-server (from to)
  372.   (interactive
  373.    (list
  374.     (or (gnus-server-server-name)
  375.     (error "No server on the current line"))
  376.     (read-string "Copy to: ")))
  377.   (or from (error "No server on current line"))
  378.   (or (and to (not (string= to ""))) (error "No name to copy to"))
  379.   (and (assoc to gnus-server-alist) (error "%s already exists" to))
  380.   (or (assoc from gnus-server-alist) 
  381.       (error "%s: no such server" from))
  382.   (let ((to-entry (gnus-copy-sequence (assoc from gnus-server-alist))))
  383.     (setcar to-entry to)
  384.     (setcar (nthcdr 2 to-entry) to)
  385.     (setq gnus-server-killed-servers 
  386.       (cons to-entry gnus-server-killed-servers))
  387.     (gnus-server-yank-server)))
  388.  
  389. (defun gnus-server-add-server (how where)
  390.   (interactive 
  391.    (list (intern (completing-read "Server method: "
  392.                   gnus-valid-select-methods nil t))
  393.      (read-string "Server name: ")))
  394.   (setq gnus-server-killed-servers 
  395.     (cons (list where how where) gnus-server-killed-servers))
  396.   (gnus-server-yank-server))
  397.  
  398. (defun gnus-server-goto-server (server)
  399.   "Jump to a server line."
  400.   (interactive
  401.    (list (completing-read "Goto server: " gnus-server-alist nil t)))
  402.   (let ((to (text-property-any (point-min) (point-max) 
  403.                    'gnus-server (intern server))))
  404.     (and to
  405.      (progn
  406.        (goto-char to) 
  407.        (gnus-server-position-point)))))
  408.  
  409. (defun gnus-server-edit-server (server)
  410.   "Edit the server on the current line."
  411.   (interactive (list (gnus-server-server-name)))
  412.   (unless server
  413.     (error "No server on current line"))
  414.   (unless (assoc server gnus-server-alist)
  415.     (error "This server can't be edited"))
  416.   (let ((winconf (current-window-configuration))
  417.     (info (cdr (assoc server gnus-server-alist))))
  418.     (gnus-close-server info)
  419.     (get-buffer-create gnus-server-edit-buffer)
  420.     (gnus-configure-windows 'edit-server)
  421.     (gnus-add-current-to-buffer-list)
  422.     (emacs-lisp-mode)
  423.     (make-local-variable 'gnus-prev-winconf)
  424.     (setq gnus-prev-winconf winconf)
  425.     (use-local-map (copy-keymap (current-local-map)))
  426.     (let ((done-func '(lambda () 
  427.             "Exit editing mode and update the information."
  428.             (interactive)
  429.             (gnus-server-edit-server-done 'group))))
  430.       (setcar (cdr (nth 4 done-func)) server)
  431.       (local-set-key "\C-c\C-c" done-func))
  432.     (erase-buffer)
  433.     (insert ";; Type `C-c C-c' after you have edited the server.\n\n")
  434.     (insert (pp-to-string info))))
  435.  
  436. (defun gnus-server-edit-server-done (server)
  437.   (interactive)
  438.   (set-buffer (get-buffer-create gnus-server-edit-buffer))
  439.   (goto-char (point-min))
  440.   (let ((form (read (current-buffer)))
  441.     (winconf gnus-prev-winconf))
  442.     (gnus-server-set-info server form)
  443.     (kill-buffer (current-buffer))
  444.     (and winconf (set-window-configuration winconf))
  445.     (set-buffer gnus-server-buffer)
  446.     (gnus-server-update-server server)
  447.     (gnus-server-list-servers)
  448.     (gnus-server-position-point)))
  449.  
  450. (defun gnus-server-read-server (server)
  451.   "Browse a server."
  452.   (interactive (list (gnus-server-server-name)))
  453.   (let ((buf (current-buffer)))
  454.     (prog1
  455.     (gnus-browse-foreign-server (gnus-server-to-method server) buf)
  456.       (save-excursion
  457.     (set-buffer buf)
  458.     (gnus-server-update-server (gnus-server-server-name))
  459.     (gnus-server-position-point)))))
  460.     
  461. (defun gnus-server-pick-server (e)
  462.   (interactive "e")
  463.   (mouse-set-point e)
  464.   (gnus-server-read-server (gnus-server-server-name)))
  465.  
  466.  
  467. ;;;
  468. ;;; Browse Server Mode
  469. ;;;
  470.  
  471. (defvar gnus-browse-menu-hook nil
  472.   "*Hook run after the creation of the browse mode menu.")
  473.  
  474. (defvar gnus-browse-mode-hook nil)
  475. (defvar gnus-browse-mode-map nil)
  476. (put 'gnus-browse-mode 'mode-class 'special)
  477.  
  478. (unless gnus-browse-mode-map
  479.   (setq gnus-browse-mode-map (make-keymap))
  480.   (suppress-keymap gnus-browse-mode-map)
  481.  
  482.   (gnus-define-keys
  483.    gnus-browse-mode-map
  484.    " " gnus-browse-read-group
  485.    "=" gnus-browse-select-group
  486.    "n" gnus-browse-next-group
  487.    "p" gnus-browse-prev-group
  488.    "\177" gnus-browse-prev-group
  489.    "N" gnus-browse-next-group
  490.    "P" gnus-browse-prev-group
  491.    "\M-n" gnus-browse-next-group
  492.    "\M-p" gnus-browse-prev-group
  493.    "\r" gnus-browse-select-group
  494.    "u" gnus-browse-unsubscribe-current-group
  495.    "l" gnus-browse-exit
  496.    "L" gnus-browse-exit
  497.    "q" gnus-browse-exit
  498.    "Q" gnus-browse-exit
  499.    "\C-c\C-c" gnus-browse-exit
  500.    "?" gnus-browse-describe-briefly
  501.  
  502.    "\C-c\C-i" gnus-info-find-node))
  503.  
  504. (defun gnus-browse-make-menu-bar ()
  505.   (gnus-visual-turn-off-edit-menu 'browse)
  506.   (or
  507.    (boundp 'gnus-browse-menu)
  508.    (progn
  509.      (easy-menu-define
  510.       gnus-browse-menu gnus-browse-mode-map ""
  511.       '("Browse"
  512.     ["Subscribe" gnus-browse-unsubscribe-current-group t]
  513.     ["Read" gnus-browse-read-group t]
  514.     ["Select" gnus-browse-read-group t]
  515.     ["Next" gnus-browse-next-group t]
  516.     ["Prev" gnus-browse-next-group t]
  517.     ["Exit" gnus-browse-exit t]
  518.     ))
  519.       (run-hooks 'gnus-browse-menu-hook))))
  520.  
  521. (defvar gnus-browse-current-method nil)
  522. (defvar gnus-browse-return-buffer nil)
  523.  
  524. (defvar gnus-browse-buffer "*Gnus Browse Server*")
  525.  
  526. (defun gnus-browse-foreign-server (method &optional return-buffer)
  527.   "Browse the server METHOD."
  528.   (setq gnus-browse-current-method method)
  529.   (setq gnus-browse-return-buffer return-buffer)
  530.   (let ((gnus-select-method method)
  531.     groups group)
  532.     (gnus-message 5 "Connecting to %s..." (nth 1 method))
  533.     (cond
  534.      ((not (gnus-check-server method))
  535.       (gnus-message
  536.        1 "Unable to contact server: %s" (gnus-status-message method))
  537.       nil)
  538.      ((not (gnus-request-list method))
  539.       (gnus-message
  540.        1 "Couldn't request list: %s" (gnus-status-message method))
  541.       nil)
  542.      (t
  543.       (get-buffer-create gnus-browse-buffer)
  544.       (gnus-add-current-to-buffer-list)
  545.       (and gnus-carpal (gnus-carpal-setup-buffer 'browse))
  546.       (gnus-configure-windows 'browse)
  547.       (buffer-disable-undo (current-buffer))
  548.       (let ((buffer-read-only nil))
  549.     (erase-buffer))
  550.       (gnus-browse-mode)
  551.       (setq mode-line-buffer-identification
  552.         (list
  553.          (format
  554.           "Gnus: %%b {%s:%s}" (car method) (cadr method))))
  555.       (save-excursion
  556.     (set-buffer nntp-server-buffer)
  557.     (let ((cur (current-buffer)))
  558.       (goto-char (point-min))
  559.       (or (string= gnus-ignored-newsgroups "")
  560.           (delete-matching-lines gnus-ignored-newsgroups))
  561.       (while (re-search-forward
  562.           "\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t)
  563.         (goto-char (match-end 1))
  564.         (setq groups (cons (cons (match-string 1)
  565.                      (max 0 (- (1+ (read cur)) (read cur))))
  566.                    groups)))))
  567.       (setq groups (sort groups
  568.              (lambda (l1 l2)
  569.                (string< (car l1) (car l2)))))
  570.       (let ((buffer-read-only nil))
  571.     (while groups
  572.       (setq group (car groups))
  573.       (insert
  574.        (format "K%7d: %s\n" (cdr group) (car group)))
  575.       (setq groups (cdr groups))))
  576.       (switch-to-buffer (current-buffer))
  577.       (goto-char (point-min))
  578.       (gnus-group-position-point)
  579.       (gnus-message 5 "Connecting to %s...done" (nth 1 method))
  580.       t))))
  581.  
  582. (defun gnus-browse-mode ()
  583.   "Major mode for browsing a foreign server.
  584.  
  585. All normal editing commands are switched off.
  586.  
  587. \\<gnus-browse-mode-map>
  588. The only things you can do in this buffer is
  589.  
  590. 1) `\\[gnus-browse-unsubscribe-current-group]' to subscribe to a group.
  591. The group will be inserted into the group buffer upon exit from this
  592. buffer.
  593.  
  594. 2) `\\[gnus-browse-read-group]' to read a group ephemerally.
  595.  
  596. 3) `\\[gnus-browse-exit]' to return to the group buffer."
  597.   (interactive)
  598.   (kill-all-local-variables)
  599.   (when (and menu-bar-mode
  600.          (gnus-visual-p 'browse-menu 'menu))
  601.     (gnus-browse-make-menu-bar))
  602.   (gnus-simplify-mode-line)
  603.   (setq major-mode 'gnus-browse-mode)
  604.   (setq mode-name "Browse Server")
  605.   (setq mode-line-process nil)
  606.   (use-local-map gnus-browse-mode-map)
  607.   (buffer-disable-undo (current-buffer))
  608.   (setq truncate-lines t)
  609.   (setq buffer-read-only t)
  610.   (run-hooks 'gnus-browse-mode-hook))
  611.  
  612. (defun gnus-browse-read-group (&optional no-article)
  613.   "Enter the group at the current line."
  614.   (interactive)
  615.   (let ((group (gnus-browse-group-name)))
  616.     (or (gnus-group-read-ephemeral-group
  617.      group gnus-browse-current-method nil
  618.      (cons (current-buffer) 'browse))
  619.     (error "Couldn't enter %s" group))))
  620.  
  621. (defun gnus-browse-select-group ()
  622.   "Select the current group."
  623.   (interactive)
  624.   (gnus-browse-read-group 'no))
  625.  
  626. (defun gnus-browse-next-group (n)
  627.   "Go to the next group."
  628.   (interactive "p")
  629.   (prog1
  630.       (forward-line n)
  631.     (gnus-group-position-point)))
  632.  
  633. (defun gnus-browse-prev-group (n)
  634.   "Go to the next group."
  635.   (interactive "p")
  636.   (gnus-browse-next-group (- n)))
  637.  
  638. (defun gnus-browse-unsubscribe-current-group (arg)
  639.   "(Un)subscribe to the next ARG groups."
  640.   (interactive "p")
  641.   (when (eobp)
  642.     (error "No group at current line."))
  643.   (let ((ward (if (< arg 0) -1 1))
  644.     (arg (abs arg)))
  645.     (while (and (> arg 0)
  646.         (not (eobp))
  647.         (gnus-browse-unsubscribe-group)
  648.         (zerop (gnus-browse-next-group ward)))
  649.       (decf arg))
  650.     (gnus-group-position-point)
  651.     (if (/= 0 arg) (gnus-message 7 "No more newsgroups"))
  652.     arg))
  653.  
  654. (defun gnus-browse-group-name ()
  655.   (save-excursion
  656.     (beginning-of-line)
  657.     (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t)
  658.       (gnus-group-prefixed-name (match-string 1) gnus-browse-current-method))))
  659.  
  660. (defun gnus-browse-unsubscribe-group ()
  661.   "Toggle subscription of the current group in the browse buffer."
  662.   (let ((sub nil)
  663.     (buffer-read-only nil)
  664.     group)
  665.     (save-excursion
  666.       (beginning-of-line)
  667.       ;; If this group it killed, then we want to subscribe it.
  668.       (if (= (following-char) ?K) (setq sub t))
  669.       (setq group (gnus-browse-group-name))
  670.       (delete-char 1)
  671.       (if sub
  672.       (progn
  673.         (gnus-group-change-level
  674.          (list t group gnus-level-default-subscribed
  675.            nil nil gnus-browse-current-method)
  676.          gnus-level-default-subscribed gnus-level-killed
  677.          (and (car (nth 1 gnus-newsrc-alist))
  678.           (gnus-gethash (car (nth 1 gnus-newsrc-alist))
  679.                 gnus-newsrc-hashtb))
  680.          t)
  681.         (insert ? ))
  682.     (gnus-group-change-level
  683.      group gnus-level-killed gnus-level-default-subscribed)
  684.     (insert ?K)))
  685.     t))
  686.  
  687. (defun gnus-browse-exit ()
  688.   "Quit browsing and return to the group buffer."
  689.   (interactive)
  690.   (when (eq major-mode 'gnus-browse-mode)
  691.     (kill-buffer (current-buffer)))
  692.   ;; Insert the newly subscribed groups in the group buffer.
  693.   (save-excursion
  694.     (set-buffer gnus-group-buffer)
  695.     (gnus-group-list-groups nil))
  696.   (if gnus-browse-return-buffer
  697.       (gnus-configure-windows 'server 'force)
  698.     (gnus-configure-windows 'group 'force)))
  699.  
  700. (defun gnus-browse-describe-briefly ()
  701.   "Give a one line description of the group mode commands."
  702.   (interactive)
  703.   (gnus-message 6
  704.         (substitute-command-keys "\\<gnus-browse-mode-map>\\[gnus-group-next-group]:Forward  \\[gnus-group-prev-group]:Backward  \\[gnus-browse-exit]:Exit  \\[gnus-info-find-node]:Run Info  \\[gnus-browse-describe-briefly]:This help")))
  705.  
  706. (provide 'gnus-srvr)
  707.  
  708. ;;; gnus-srvr.el ends here.
  709.